home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
elk-2_0.lha
/
elk-2.0
/
src
/
io.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-10-21
|
9KB
|
358 lines
/* Ports
*/
#include "scheme.h"
#include <errno.h>
#include <pwd.h>
#include <sys/types.h>
#include <sys/param.h>
#include <sys/stat.h>
#ifdef SYSCONF
# include <unistd.h>
#endif
extern int errno;
extern char *getenv();
Object Curr_Input_Port, Curr_Output_Port;
Object Standard_Input_Port, Standard_Output_Port;
Object Make_Port();
Init_Io () {
Standard_Input_Port = Make_Port (P_INPUT, stdin, Make_String ("stdin", 5));
Standard_Output_Port = Make_Port (0, stdout, Make_String ("stdout", 6));
Curr_Input_Port = Standard_Input_Port;
Curr_Output_Port = Standard_Output_Port;
Global_GC_Link (Standard_Input_Port);
Global_GC_Link (Standard_Output_Port);
Global_GC_Link (Curr_Input_Port);
Global_GC_Link (Curr_Output_Port);
}
Reset_IO (destructive) {
Discard_Input (Curr_Input_Port);
if (destructive)
Discard_Output (Curr_Output_Port);
else
Flush_Output (Curr_Output_Port);
Curr_Input_Port = Standard_Input_Port;
Curr_Output_Port = Standard_Output_Port;
}
Object Make_Port (flags, f, name) FILE *f; Object name; {
Object port;
GC_Node;
GC_Link (name);
port = Alloc_Object (sizeof (struct S_Port), T_Port, 0);
PORT(port)->flags = flags|P_OPEN;
PORT(port)->file = f;
PORT(port)->name = name;
PORT(port)->ptr = 0;
PORT(port)->lno = 1;
GC_Unlink;
return port;
}
Object P_Port_File_Name (p) Object p; {
Check_Type (p, T_Port);
return (PORT(p)->flags & P_STRING) ? False : PORT(p)->name;
}
Object P_Port_Line_Number (p) Object p; {
Check_Type (p, T_Port);
return Make_Unsigned (PORT(p)->lno);
}
Object P_Eof_Objectp (x) Object x; {
return TYPE(x) == T_End_Of_File ? True : False;
}
Object P_Curr_Input_Port () { return Curr_Input_Port; }
Object P_Curr_Output_Port () { return Curr_Output_Port; }
Object P_Input_Portp (x) Object x; {
return TYPE(x) == T_Port && IS_INPUT(x) ? True : False;
}
Object P_Output_Portp (x) Object x; {
return TYPE(x) == T_Port && IS_OUTPUT(x) ? True : False;
}
int Path_Max () {
#ifdef PATH_MAX /* POSIX */
return PATH_MAX;
#else
#ifdef MAXPATHLEN /* 4.3 BSD */
return MAXPATHLEN;
#else
#ifdef SYSCONF
static r;
if (r == 0) {
if ((r = pathconf ("/", _PC_PATH_MAX)) == -1)
r = 1024;
r++;
}
return r;
#else
return 1024;
#endif
#endif
#endif
}
Object Get_File_Name (name) Object name; {
register len;
if (TYPE(name) == T_Symbol)
name = SYMBOL(name)->name;
else if (TYPE(name) != T_String)
Wrong_Type_Combination (name, "string or symbol");
if ((len = STRING(name)->size) > Path_Max () || len == 0)
Primitive_Error ("invalid file name");
return name;
}
char *Internal_Tilde_Expand (s, dirp) register char *s, **dirp; {
register char *p;
struct passwd *pw, *getpwnam();
if (*s++ != '~')
return 0;
for (p = s; *p && *p != '/'; p++)
;
if (*p == '/') *p++ = 0;
if (*s == '\0') {
if ((*dirp = getenv ("HOME")) == 0)
*dirp = "";
} else {
if ((pw = getpwnam (s)) == 0)
Primitive_Error ("unknown user: ~a", Make_String (s, strlen (s)));
*dirp = pw->pw_dir;
}
return p;
}
Object General_File_Operation (s, op) Object s; register op; {
register char *r;
Object ret, fn;
Alloca_Begin;
fn = Get_File_Name (s);
Make_C_String (fn, r);
switch (op) {
case 0: {
char *p, *dir;
if ((p = Internal_Tilde_Expand (r, &dir)) == 0) {
Alloca_End;
return s;
}
Alloca (r, char*, strlen (dir) + 1 + strlen (p));
sprintf (r, "%s/%s", dir, p);
ret = Make_String (r, strlen (r));
Alloca_End;
return ret;
}
case 1: {
struct stat st;
/* Doesn't make much sense to check for errno != ENOENT here:
*/
ret = stat (r, &st) == 0 ? True : False;
Alloca_End;
return ret;
}}
/*NOTREACHED*/
}
Object P_Tilde_Expand (s) Object s; {
return General_File_Operation (s, 0);
}
Object P_File_Existsp (s) Object s; {
return General_File_Operation (s, 1);
}
Close_All_Files () {
Terminate_All (T_Port);
}
void Terminate_File (port) Object port; {
(void)fclose (PORT(port)->file);
PORT(port)->flags &= ~P_OPEN;
}
Object Open_File (name, flags, err) char *name; {
register FILE *f;
char *dir, *p;
Object fn, port;
struct stat st;
Alloca_Begin;
if (p = Internal_Tilde_Expand (name, &dir)) {
Alloca (name, char*, strlen (dir) + 1 + strlen (p));
sprintf (name, "%s/%s", dir, p);
}
if (!err && stat (name, &st) == -1 &&
(errno == ENOENT || errno == ENOTDIR)) {
Alloca_End;
return Null;
}
switch (flags & (P_INPUT|P_BIDIR)) {
case 0: p = "w"; break;
case P_INPUT: p = "r"; break;
default: p = "r+"; break;
}
fn = Make_String (name, strlen (name));
if ((f = fopen (name, p)) == NULL) {
Saved_Errno = errno; /* errno valid here? */
Primitive_Error ("~s: ~E", fn);
}
port = Make_Port (flags, f, fn);
Register_Terminate (port, Terminate_File);
Alloca_End;
return port;
}
Object General_Open_File (name, flags, path) Object name, path; {
Object port, pref;
char *buf = 0;
register char *fn;
register plen, len, blen = 0, gotpath = 0;
Alloca_Begin;
name = Get_File_Name (name);
len = STRING(name)->size;
fn = STRING(name)->data;
if (fn[0] != '/' && fn[0] != '~') {
for ( ; TYPE(path) == T_Pair; path = Cdr (path)) {
pref = Car (path);
if (TYPE(pref) == T_Symbol)
pref = SYMBOL(pref)->name;
if (TYPE(pref) != T_String)
continue;
gotpath = 1;
if ((plen = STRING(pref)->size) > Path_Max () || plen == 0)
continue;
if (len + plen + 2 > blen) {
blen = len + plen + 2;
Alloca (buf, char*, blen);
}
bcopy (STRING(pref)->data, buf, plen);
if (buf[plen-1] != '/')
buf[plen++] = '/';
bcopy (fn, buf+plen, len);
buf[len+plen] = '\0';
port = Open_File (buf, flags, 0);
/* No GC has been taken place in Open_File() if it returns Null.
*/
if (!Nullp (port)) {
Alloca_End;
return port;
}
}
}
if (gotpath)
Primitive_Error ("file ~s not found", name);
if (len + 1 > blen)
Alloca (buf, char*, len + 1);
bcopy (fn, buf, len);
buf[len] = '\0';
port = Open_File (buf, flags, 1);
Alloca_End;
return port;
}
Object P_Open_Input_File (name) Object name; {
return General_Open_File (name, P_INPUT, Null);
}
Object P_Open_Output_File (name) Object name; {
return General_Open_File (name, 0, Null);
}
Object P_Open_Input_Output_File (name) Object name; {
return General_Open_File (name, P_BIDIR, Null);
}
Object General_Close_Port (port) Object port; {
register flags;
FILE *f;
Check_Type (port, T_Port);
flags = PORT(port)->flags;
if (!(flags & P_OPEN) || (flags & P_STRING))
return Void;
f = PORT(port)->file;
if (f == stdin || f == stdout)
return Void;
if (fclose (f) == EOF) {
Saved_Errno = errno; /* errno valid here? */
Primitive_Error ("write error on ~s: ~E", port);
}
PORT(port)->flags &= ~P_OPEN;
Deregister_Terminate (port);
return Void;
}
Object P_Close_Input_Port (port) Object port; {
return General_Close_Port (port);
}
Object P_Close_Output_Port (port) Object port;{
return General_Close_Port (port);
}
#define General_With(prim,curr,flags) Object prim (name, thunk)\
Object name, thunk; {\
Object old, ret;\
GC_Node2;\
\
Check_Procedure (thunk);\
old = curr;\
GC_Link2 (thunk, old);\
curr = General_Open_File (name, flags, Null);\
ret = Funcall (thunk, Null, 0);\
(void)General_Close_Port (curr);\
GC_Unlink;\
curr = old;\
return ret;\
}
General_With (P_With_Input, Curr_Input_Port, P_INPUT)
General_With (P_With_Output, Curr_Output_Port, 0)
Object General_Call_With (name, flags, proc) Object name, proc; {
Object port, ret;
GC_Node2;
Check_Procedure (proc);
GC_Link2 (proc, port);
port = General_Open_File (name, flags, Null);
port = Cons (port, Null);
ret = Funcall (proc, port, 0);
(void)General_Close_Port (Car (port));
GC_Unlink;
return ret;
}
Object P_Call_With_Input (name, proc) Object name, proc; {
return General_Call_With (name, P_INPUT, proc);
}
Object P_Call_With_Output (name, proc) Object name, proc; {
return General_Call_With (name, 0, proc);
}
Object P_Open_Input_String (string) Object string; {
Check_Type (string, T_String);
return Make_Port (P_STRING|P_INPUT, (FILE *)0, string);
}
Object P_Open_Output_String () {
return Make_Port (P_STRING, (FILE *)0, Make_String ((char *)0, 0));
}